home *** CD-ROM | disk | FTP | other *** search
/ Power CD-ROM!! 8 / Power CD-ROM 8.iso / prgmming / pmd110 / bbfile.pas < prev    next >
Pascal/Delphi Source File  |  1994-11-13  |  26KB  |  366 lines
  1. (* This file was mangled by Mangler 1.35 (c) Copyright 1993-1994 by Berend de Boer *)
  2. { Created : 91-01-18
  3.  
  4.   This unit implementents an interface such as the dos command.com. Use it
  5.   for easy copying and erasing one or more files.
  6.   Probably not every dos command line combination is valid! Check the not
  7.   so common ones.
  8.  
  9. Uses string identifiers 1900..1919
  10.  
  11. Last changes :
  12. 91-07-15  Copied from Turbo Pascal 5.5 and adapted to version 6
  13. 92-06-13  Copied some files from BBUTIL
  14.           Added procedure Wipe
  15. 92-10-14  Added function FDefaultExtension
  16.           Added function FForceExtenstion
  17. 92-11-28  Added function OpenFile which opens a file in a specified mode
  18. 93-03-15  Removed language dependency, use a string resource instead
  19.           Added function IOError (removed from BBDlg)
  20. 93-03-24  Added function GetFileName
  21. 93-04-12  Added function GetUniqueFileName
  22.           Changed function SetHandleCount to one that works on dos 3.0+
  23.           with thanks to Bob Swart who posted this code more or less in the
  24.           PASCAL.028 echo
  25. 93-09-11  Added DosMove
  26. 93-09-20  Rewritten DosCopy and DosMove. Added full wildcard support. Added
  27.           better share support.
  28.           DosCopy now uses streams instead of BlockReads.
  29. 93-10-02  Added function FForceDir
  30. 93-10-04  Renamed Touch to DosTouch
  31. 93-10-23  CreateBak rewritten to a procedure
  32. 93-12-03  Added function XParamStr, a more intelligent ParamStr parser
  33. 93-12-20  Added GetTextFileName to return the name of a textfile
  34. 94-01-10  Changed FileExist to use GetFAttr instead of FindFirst. Could
  35.           break code that depended on use of FindFirst!
  36. 94-02-21  Changed GetUniqueFileName. Now a path should be given to create
  37.           the unique file.
  38. 94-05-02  Fixed bug in DosCopy and DosMove when as destination a filename
  39.           was specified
  40.           Added function IsDirectory
  41. 94-05-16  Adapted to the Windows environment
  42. 94-08-29  Added procedure XMkDir, an extension of MkDir that allows for
  43.           recursive subdirectory creation
  44. 94-09-06  Added TSmartBufStream, a stream which doesn't do a GetPos, GetSize
  45.           or Seek unless really necessary. GetPos or Seeks are very expensive
  46.           especially with small reads so this object adds smarter caching to
  47.           TBufStream
  48. 94-10-07  Added procedures AddTrailingBackSlash and RemoveTrailingBackSlash,
  49.           meant for directories.
  50. }
  51.  
  52.  
  53.  
  54. {$IFDEF MSDos}
  55. {$D-,F+,O+,R-,Q-,V-}
  56. {$ENDIF}
  57.  
  58. {$I-,S-,X+}
  59. unit BBFile;
  60.  
  61. interface
  62.  
  63. uses {$IFDEF Windows}
  64.      WinDos,
  65.      {$ELSE}
  66.      Dos,
  67.      {$ENDIF}
  68.      Objects;
  69.  
  70.  
  71. {* file mode constants *}
  72.  
  73. const
  74.   fmReadOnly  = $0000;
  75.   fmWriteOnly = $0001;
  76.   fmCreate    = $0001;
  77.   fmReadWrite = $0002;
  78.   fmDenyAll   = $0010;
  79.   fmDenyWrite = $0020;
  80.   fmDenyRead  = $0030;
  81.   fmDenyNone  = $0040;
  82.   fmNoWait    = $0100;
  83.  
  84.  
  85. {* stream open and create constants. Filemode constants can simply added to *}
  86. {* these base values                                                        *}
  87.  
  88. const
  89.   stCreate = $3C00;
  90.   stOpen   = $3D00;
  91.  
  92. type
  93.   TDriveStr = string[2];
  94.  
  95. {$IFDEF Windows}
  96. {* define some types and constants defined in Dos, but not in WinDos *}
  97. {* this to ease porting *}
  98. const
  99.   Archive = faArchive;
  100.  
  101. type
  102.   PathStr = string[79];
  103.   DirStr = string[67];
  104.   NameStr = string[8];
  105.   ExtStr = string[4];
  106.  
  107. type
  108.   SearchRec = TSearchRec;
  109.  
  110. type
  111.   DateTime = TDateTime;
  112.  
  113. type
  114.   FileRec = TFileRec;
  115.  
  116. type
  117.   Registers = TRegisters;
  118.  
  119. type
  120.   TextRec = TTextRec;
  121. {$ENDIF}
  122.  
  123.  
  124. const
  125.   IOErrNum:integer = 0;           { set by IOError }
  126.  
  127. const
  128.   TicksToWait:integer = 6;        { how many clock ticks to wait before }
  129.                                   { FOpen/FCreate fails }
  130.  
  131.  
  132. { DOS routines }
  133.  
  134. procedure DosDel(Path : PathStr);
  135. procedure DosCopy(Source, Destination : PathStr; AHelpCtx : word);
  136. procedure DosMove(const Source : PathStr; Dest : PathStr; AHelpCtx : word);
  137. procedure DosWipe(const Path : PathStr);
  138. procedure DosTouch(const Path : PathStr);
  139.  
  140.  
  141. { various file functions }
  142.  
  143. procedure AddTrailingBackSlash(var Dir : PathStr);
  144. procedure CreateBAK(const FileName : PathStr; HelpCtx : word);
  145. function  FCreate(var f : file; AFileMode : word) : integer;
  146. function  FDefaultExtension(const FileName : PathStr; const Ext : ExtStr) : string;
  147. {$IFDEF Windows}
  148. function  FExpand(Path: PathStr): PathStr;
  149. {$ENDIF}
  150. function  FForceDir(const FileName : PathStr; Dir : DirStr) : string;
  151. function  FForceExtension(const FileName : PathStr; const Ext : ExtStr) : string;
  152. function  FileExist(const FileName : PathStr) : Boolean;
  153. function  FOpen(var f : file; AFileMode : word) : integer;
  154. procedure ForEachFile(const Path : PathStr; Attr : word; Action : pointer);
  155. function  GetDrive : TDriveStr;
  156. {$IFDEF Windows}
  157. function  GetEnv(const EnvVar : string) : string;
  158. {$ENDIF}
  159. function  GetFileName(var f : file) : string;
  160. function  GetTextFileName(var t : text) : string;
  161. function  GetUniqueFileName(const Dir : PathStr) : string;
  162. function  IsDirectory(Dir : DirStr) : Boolean;
  163. function  IsFileOpen(var f) : Boolean;
  164. function  IOError(const s : string; AHelpCtx : word) : Boolean;
  165. function  MatchFileNames(const Source, Dest : PathStr) : string;
  166. procedure RemoveTrailingBackSlash(var Dir : PathStr);
  167. procedure SetHandleCount(Handles : word);
  168. procedure SetHandleCountDos3(Handles : word);
  169. procedure XMkDir(Path : PathStr);
  170. procedure XFSplit(const Path : PathStr;
  171.                   var Dir : DirStr;
  172.                   var Name : NameStr;
  173.                   var Ext : ExtStr);
  174. function  XParamStr(Index : word) : string;
  175.  
  176.  
  177.  
  178. type
  179.   PSmartBufStream = ^TSmartBufStream;
  180.   TSmartBufStream = object(TBufStream)
  181.     constructor Init(const FileName : FNameStr; Mode, Size : word);
  182.     function  GetPos : longint; virtual;
  183.     function  GetSize : longint; virtual;
  184.     procedure Read(var Buf; Count : word); virtual;
  185.     procedure ResizeBuffer(NewSize : word);
  186.     procedure Seek(Pos : longint); virtual;
  187.     procedure Truncate; virtual;
  188.     procedure Write(var Buf; Count : word); virtual;
  189.   private
  190.     FilePosCache : longint;
  191.     GetSizeCache : longint;
  192.     GetPosCache : longint;
  193.   end;
  194.  
  195.  
  196.  
  197.  IMPLEMENTATION USES BBUTIL , {$IFDEF DPMI}WINAPI , {$ENDIF}{$IFDEF Debug}ASSERTIONS , {$ENDIF}{$IFDEF Windows}STRINGS ,
  198. WINPROCS , {$ENDIF}BBCONST , BBERROR , BBSTRRES , BBGUI ;PROCEDURE DOSDEL (PATH:PATHSTR);PROCEDURE Ol01l1O010
  199. (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;BEGIN ASSIGN (OIl0 , Ol1O0OOI );ERASE (OIl0 );IOERROR (Ol1O0OOI , 0 );END ;
  200. BEGIN FOREACHFILE (PATH , ARCHIVE , @ Ol01l1O010 );END ;PROCEDURE DOSCOPY (SOURCE,DESTINATION:PATHSTR;AHELPCTX:WORD);
  201. PROCEDURE O1lIOlO0O1l1 ;VAR OIOOlO1I0l1:BOOLEAN;O1OOlI1IIIOO:BYTE;PROCEDURE O101IlO10I10I (VAR OIOOlO1I0l1:BOOLEAN);
  202. VAR OO01:LONGINT;BEGIN BEEP ;{$IFDEF Windows}OIOOlO1I0l1 := USERANSWER (RSGET1 (SINFORMUSER , O1OOlI1IIIOO + ORD ('A')- 1
  203. ), AHELPCTX )=CMYES ;{$ELSE}IF BBSTRRES.STRINGS =NIL THEN OIOOlO1I0l1 := USERANSWER ('Disk is full. Insert new disk in '+
  204. 'drive '+ CHR (O1OOlI1IIIOO + ORD ('A')- 1 ), 0 )=CMYES ELSE OIOOlO1I0l1 := USERANSWER (RSGET1 (SINFORMUSER ,
  205. O1OOlI1IIIOO + ORD ('A')- 1 ), AHELPCTX )=CMYES ;{$ENDIF}END ;PROCEDURE Oll1OIl0OO (CONST OI0lI1010ll1:PATHSTR);
  206. FAR;VAR OIl1IOO00lI:PATHSTR;OIl10I10l,OI110IOOO0l0:PDOSSTREAM;{$IFDEF Windows}O11l0IO0:ARRAY [ 0 .. 255 ]  OF CHAR;
  207. {$ENDIF}BEGIN {$IFDEF Windows}OIl10I10l := NEW (PBUFSTREAM , INIT (STRPCOPY (O11l0IO0 , OI0lI1010ll1 ), STOPEN +
  208. FMREADONLY + FMDENYWRITE , 8192 ));{$ELSE}OIl10I10l := NEW (PBUFSTREAM , INIT (OI0lI1010ll1 , STOPEN + FMREADONLY +
  209. FMDENYWRITE , 8192 ));{$ENDIF}IF OIl10I10l ^. STATUS <> STOK THEN BEGIN PRINTERROR ('Could not read '+ OI0lI1010ll1 +
  210. '.', AHELPCTX );EXIT ;END ;OIl1IOO00lI := MATCHFILENAMES (OI0lI1010ll1 , DESTINATION );{$IFDEF Windows}OI110IOOO0l0 :=
  211. NEW (PBUFSTREAM , INIT (STRPCOPY (O11l0IO0 , OIl1IOO00lI ), STCREATE + FMWRITEONLY + FMDENYALL , 8192 ));
  212. {$ELSE}OI110IOOO0l0 := NEW (PBUFSTREAM , INIT (OIl1IOO00lI , STCREATE + FMWRITEONLY + FMDENYALL , 8192 ));{$ENDIF}IF
  213. OI110IOOO0l0 ^. STATUS <> STOK THEN BEGIN PRINTERROR ('Could not create '+ OIl1IOO00lI + '.', AHELPCTX );EXIT ;END ;
  214. OI110IOOO0l0 ^. COPYFROM (OIl10I10l ^, OIl10I10l ^. GETSIZE );ASM {} LES DI , OIl10I10l{}
  215. MOV BX , ES : [ DI ] . TDOSSTREAM.HANDLE{} MOV AX , 5700h {} INT 21h {} LES DI , OI110IOOO0l0{}
  216. MOV BX , ES : [ DI ] . TDOSSTREAM.HANDLE{} MOV AX , 5701h {} INT 21h {} END;DISPOSE (OI110IOOO0l0 , DONE );DISPOSE
  217. (OIl10I10l , DONE );END ;BEGIN IF (DESTINATION [ LENGTH (DESTINATION )] <> '\')AND ISDIRECTORY (DESTINATION )THEN
  218. DESTINATION := DESTINATION + '\';FOREACHFILE (SOURCE , ARCHIVE , @ Oll1OIl0OO );END ;BEGIN IF MAXAVAIL < 3 * 8192 THEN
  219. BEGIN {$IFDEF Windows}PRINTERROR (RSGET (SNOTENOUGHMEMORY ), AHELPCTX );{$ELSE}IF BBSTRRES.STRINGS =NIL THEN PRINTERROR
  220. ('Not enough memory to copy files.', AHELPCTX )ELSE PRINTERROR (RSGET (SNOTENOUGHMEMORY ), AHELPCTX );{$ENDIF}DOSERROR :=
  221. 8 ;END ELSE O1lIOlO0O1l1 ;END ;PROCEDURE DOSMOVE (CONST SOURCE:PATHSTR;DEST:PATHSTR;AHELPCTX:WORD);PROCEDURE Ol1l0OOl1O
  222. (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;O1lO0I00IOlO:PATHSTR;BEGIN O1lO0I00IOlO := MATCHFILENAMES (Ol1O0OOI , DEST );
  223. ASSIGN (OIl0 , O1lO0I00IOlO );DOSDEL (O1lO0I00IOlO );ASSIGN (OIl0 , Ol1O0OOI );RENAME (OIl0 , O1lO0I00IOlO );IOERROR
  224. (Ol1O0OOI , 0 );END ;VAR OI0lOOI1ll1O,O1OO1IIl010I:TDRIVESTR;O101IO1IOlIl1:SEARCHREC;BEGIN {$IFDEF Debug}ASSERT ((SOURCE
  225. <> '')AND (DEST <> ''), 'Source or destination empty');{$ENDIF}IF SOURCE =DEST THEN EXIT ;IF SOURCE [ 2 ] =':'THEN
  226. OI0lOOI1ll1O := UPSTR (COPY (SOURCE , 1 , 2 ))ELSE OI0lOOI1ll1O := GETDRIVE ;IF DEST [ 2 ] =':'THEN O1OO1IIl010I := UPSTR
  227. (COPY (DEST , 1 , 2 ))ELSE O1OO1IIl010I := GETDRIVE ;IF OI0lOOI1ll1O <> O1OO1IIl010I THEN BEGIN DOSCOPY (SOURCE , DEST ,
  228. AHELPCTX );DOSDEL (SOURCE );END ELSE BEGIN IF (DEST [ LENGTH (DEST )] <> '\')AND ISDIRECTORY (DEST )THEN DEST := DEST +
  229. '\';FOREACHFILE (SOURCE , ARCHIVE , @ Ol1l0OOl1O );END ;END ;PROCEDURE DOSWIPE (CONST PATH:PATHSTR);VAR OIl0:FILE ;
  230. O101IO1IOlIl1:SEARCHREC;PROCEDURE OlOII10100 (VAR OIl0:FILE );CONST O1lI00Oll1lO:BYTE=0 ;OI1II1OIOIOl:BYTE=$FF ;
  231. OI1IIO00I1ll:BYTE=$F6 ;VAR OIO11IOOlO0:WORD;OIlO:LONGINT;OIll:WORD;BEGIN RESET (OIl0 , 1 );FOR OIll := 1 TO 3
  232.  DO BEGIN SEEK (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , OI1II1OIOIOl , 1 , OIO11IOOlO0 );
  233. SEEK (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , O1lI00Oll1lO , 1 , OIO11IOOlO0 );END ;SEEK
  234. (OIl0 , 0 );FOR OIlO := 0 TO FILESIZE (OIl0 )- 1  DO BLOCKWRITE (OIl0 , OI1IIO00I1ll , 1 , OIO11IOOlO0 );CLOSE (OIl0 );
  235. END ;PROCEDURE OOlI1IlI0O0O ;BEGIN RESET (OIl0 );TRUNCATE (OIl0 );CLOSE (OIl0 );RENAME (OIl0 , 'TMP00000.$$$');END ;
  236. VAR {$IFDEF Windows}OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;OOlOO1OIl000:ARRAY [ 0 .. FSDIRECTORY]  OF CHAR;
  237. OI111IlIO110:ARRAY [ 0 .. FSFILENAME]  OF CHAR;OO01IOOlI11:ARRAY [ 0 .. FSEXTENSION]  OF CHAR;{$ELSE}OIOO:DIRSTR;
  238. OO0O:NAMESTR;OIOl:EXTSTR;{$ENDIF}BEGIN {$IFDEF Windows}FILESPLIT (STRPCOPY (OIlIl0O00Il , PATH ), OOlOO1OIl000 ,
  239. OI111IlIO110 , OO01IOOlI11 );FINDFIRST (OIlIl0O00Il , FAARCHIVE , O101IO1IOlIl1 );{$ELSE}FSPLIT (PATH , OIOO , OO0O ,
  240. OIOl );FINDFIRST (PATH , ARCHIVE , O101IO1IOlIl1 );{$ENDIF}WHILE DOSERROR =0  DO BEGIN {$IFDEF Windows}ASSIGN (OIl0 ,
  241. STRPAS (OOlOO1OIl000 )+ O101IO1IOlIl1.NAME );{$ELSE}ASSIGN (OIl0 , OIOO + O101IO1IOlIl1.NAME );{$ENDIF}OlOII10100 (OIl0
  242. );OOlI1IlI0O0O ;ERASE (OIl0 );FINDNEXT (O101IO1IOlIl1 );END ;END ;PROCEDURE DOSTOUCH (CONST PATH:PATHSTR);
  243. PROCEDURE O1l0IOlIOOOO (CONST Ol1O0OOI:PATHSTR);FAR;VAR OIl0:FILE ;OI111O0100ll:LONGINT;OO1l:DATETIME;
  244. OOIl,OIO0OI11l1l,O101OO1O,OIlO11001ll:WORD;OIlI,OO0I,OO1O,O10lO0O0:WORD;BEGIN ASSIGN (OIl0 , Ol1O0OOI );RESET (OIl0 , 1
  245. );GETFTIME (OIl0 , OI111O0100ll );UNPACKTIME (OI111O0100ll , OO1l );GETDATE (OOIl , OIO0OI11l1l , O101OO1O , OIlO11001ll
  246. );GETTIME (OIlI , OO0I , OO1O , O10lO0O0 );WITH OO1l DO BEGIN YEAR := OOIl ;MONTH := OIO0OI11l1l ;DAY := O101OO1O ;HOUR
  247. := OIlI ;MIN := OO0I ;SEC := OO1O ;END ;PACKTIME (OO1l , OI111O0100ll );SETFTIME (OIl0 , OI111O0100ll );CLOSE (OIl0 );
  248. END ;BEGIN FOREACHFILE (PATH , ARCHIVE , @ O1l0IOlIOOOO );END ;PROCEDURE ADDTRAILINGBACKSLASH (VAR DIR:PATHSTR);BEGIN IF
  249. DIR [ LENGTH (DIR )] <> '\'THEN DIR := DIR + '\';END ;PROCEDURE CREATEBAK (CONST FILENAME:PATHSTR;HELPCTX:WORD);
  250. BEGIN DOSMOVE (FILENAME , FFORCEEXTENSION (FILENAME , '.BAK'), HELPCTX );END ;FUNCTION FCREATE (VAR F:FILE ;
  251. AFILEMODE:WORD):INTEGER ;VAR OIO11IOOlO0:WORD;O1011l1l0llI0:LONGINT;BEGIN IF AFILEMODE AND FMWRITEONLY <> 0 THEN
  252. BEGIN AFILEMODE := AFILEMODE AND NOT FMWRITEONLY ;AFILEMODE := AFILEMODE OR FMREADWRITE ;END ;O1011l1l0llI0 :=
  253. TICKSTOWAIT ;REPEAT REWRITE (F , 1 );OIO11IOOlO0 := IORESULT ;IF OIO11IOOlO0 =0 THEN BEGIN CLOSE (F );OIO11IOOlO0 :=
  254. FOPEN (F , AFILEMODE );END ;UNTIL (AFILEMODE AND FMNOWAIT =0 )OR (OIO11IOOlO0 =0 )OR (O1011l1l0llI0 + TICKSTOWAIT >=
  255. GETTICKCOUNT );FCREATE := OIO11IOOlO0 ;END ;FUNCTION FDEFAULTEXTENSION (CONST FILENAME:PATHSTR;CONST EXT:EXTSTR):STRING ;
  256. VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );IF OIOl =''THEN FDEFAULTEXTENSION
  257. := FILENAME + EXT ELSE FDEFAULTEXTENSION := FILENAME ;END ;{$IFDEF Windows}FUNCTION FEXPAND (PATH:PATHSTR):PATHSTR ;
  258. VAR OIlI1OlO00I,OI0lO01l1IlI:ARRAY [ 0 .. 127 ]  OF CHAR;BEGIN FILEEXPAND (OIlI1OlO00I , STRPCOPY (OI0lO01l1IlI , PATH
  259. ));FEXPAND := STRPAS (OIlI1OlO00I );END ;{$ENDIF}FUNCTION FFORCEEXTENSION (CONST FILENAME:PATHSTR;
  260. CONST EXT:EXTSTR):STRING ;VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );
  261. FFORCEEXTENSION := OIOO + OO0O + EXT ;END ;FUNCTION FFORCEDIR (CONST FILENAME:PATHSTR;DIR:DIRSTR):STRING ;
  262. VAR OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;BEGIN XFSPLIT (FILENAME , OIOO , OO0O , OIOl );IF (DIR <> '')AND (DIR [ LENGTH
  263. (DIR )] <> '\')THEN DIR := DIR + '\';FFORCEDIR := DIR + OO0O + OIOl ;END ;FUNCTION FILEEXIST
  264. (CONST FILENAME:PATHSTR):BOOLEAN ;VAR OIl0:FILE ;Ol00IO0IOlO0:WORD;BEGIN ASSIGN (OIl0 , FILENAME );GETFATTR (OIl0 ,
  265. Ol00IO0IOlO0 );FILEEXIST := DOSERROR =0 ;END ;FUNCTION FOPEN (VAR F:FILE ;AFILEMODE:WORD):INTEGER ;VAR O111O11I:BYTE;
  266. OIOO:WORD;O1011l1l0llI0:LONGINT;BEGIN O1011l1l0llI0 := GETTICKCOUNT ;O111O11I := FILEMODE ;FILEMODE := AFILEMODE ;RESET
  267. (F , 1 );WHILE (AFILEMODE AND FMNOWAIT =0 )AND (INOUTRES <> 0 )AND (O1011l1l0llI0 + TICKSTOWAIT <= GETTICKCOUNT
  268. ) DO BEGIN CASE INOUTRES  OF 33 , 32 , 5 , 162 :DELAY (100 );ELSE BEGIN IF ISFILEOPEN (FERR )THEN WRITELN (FERR ,
  269. 'FOpen IOError = ', INOUTRES );BREAK ;END ;END ;OIOO := IORESULT ;RESET (F , 1 );END ;FOPEN := IORESULT ;;FILEMODE :=
  270. O111O11I ;END ;PROCEDURE FOREACHFILE (CONST PATH:PATHSTR;ATTR:WORD;ACTION:POINTER);VAR O101IO1IOlIl1:SEARCHREC;
  271. {$IFDEF Windows}OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;{$ENDIF}OIOO:DIRSTR;OO0O:NAMESTR;OIOl:EXTSTR;
  272. OIOI0l0II11:PATHSTR;BEGIN XFSPLIT (PATH , OIOO , OO0O , OIOl );{$IFDEF Windows}FINDFIRST (STRPCOPY (OIlIl0O00Il , PATH ),
  273. ATTR , O101IO1IOlIl1 );{$ELSE}FINDFIRST (PATH , ATTR , O101IO1IOlIl1 );{$ENDIF}WHILE DOSERROR =0
  274.  DO BEGIN {$IFDEF Windows}OIOI0l0II11 := OIOO + STRPAS (O101IO1IOlIl1.NAME );{$ELSE}OIOI0l0II11 := OIOO +
  275. O101IO1IOlIl1.NAME ;{$ENDIF}ASM {} MOV AX , SS {} LEA DI , OIOI0l0II11{} PUSH AX {} PUSH DI {} {$IFDEF Windows} {}
  276. MOV AX , [ BP ] {} AND AL , 0FEH {} PUSH AX {} {$ELSE} {} PUSH WORD PTR [ BP ] {} {$ENDIF} {} CALL ACTION{} END;FINDNEXT
  277. (O101IO1IOlIl1 );END ;END ;FUNCTION GETDRIVE :TDRIVESTR ;VAR O10O11I0I01O0:REGISTERS;OO1O:TDRIVESTR;
  278. BEGIN O10O11I0I01O0.AX := $1900 ;MSDOS (O10O11I0I01O0 );GETDRIVE := CHR (65 + O10O11I0I01O0.AL )+ ':';END ;
  279. {$IFDEF Windows}FUNCTION GETENV (CONST ENVVAR:STRING ):STRING ;VAR OIlI1OlO00I:ARRAY [ 0 .. 127 ]  OF CHAR;OO10:PCHAR;
  280. BEGIN OO10 := GETENVVAR (STRPCOPY (OIlI1OlO00I , ENVVAR ));IF OO10 =NIL THEN GETENV := ''ELSE GETENV := STRPAS (OO10 );
  281. END ;{$ENDIF}FUNCTION GETFILENAME (VAR F:FILE ):STRING ;BEGIN GETFILENAME := COPY (FILEREC (F ). NAME , 1 , POS (#0,
  282. FILEREC (F ). NAME )- 1 );END ;FUNCTION GETTEXTFILENAME (VAR T:TEXT):STRING ;BEGIN GETTEXTFILENAME := COPY (TEXTREC (T ).
  283. NAME , 1 , POS (#0, TEXTREC (T ). NAME )- 1 );END ;FUNCTION GETUNIQUEFILENAME (CONST DIR:PATHSTR):STRING ;
  284. VAR OO1O:PATHSTR;OIlO:INTEGER;BEGIN FILLCHAR (OO1O , SIZEOF (OO1O ), 0 );OO1O := DIR ;IF OO1O [ LENGTH (OO1O )] <>
  285. '\'THEN OO1O := OO1O + '\';ASM {} PUSH DS {} MOV CL , SYSTEM.FILEMODE{} XOR CH , CH {} MOV AX , SS {} MOV DS , AX {}
  286. LEA DX , OO1O[ 1 ] {} MOV AH , 05ah {} INT 021h {} MOV BX , AX {} MOV AH , 03eh {} INT 021h {} MOV AH , 041h {}
  287. INT 021h {} POP DS {} END;OIlO := LENGTH (OO1O )+ 2 ;WHILE OO1O [ OIlO ] <> #0 DO INC (OIlO );OO1O [ 0 ] := CHR (OIlO - 1
  288. );GETUNIQUEFILENAME := OO1O ;END ;FUNCTION ISDIRECTORY (DIR:DIRSTR):BOOLEAN ;VAR OI1Il0OlO1I1:BYTE;O101I10lOIOOI:DIRSTR;
  289. OI10O00llI:DIRSTR;BEGIN {$IFDEF Debug}ASSERT (DIR <> '', '');{$ENDIF}GETDIR (0 , OI10O00llI );IF DIR [ LENGTH (DIR )]
  290. ='\'THEN DELETE (DIR , LENGTH (DIR ), 1 );IF (LENGTH (DIR )>= 2 )AND (DIR [ 2 ] =':')THEN OI1Il0OlO1I1 := ORD (UPCASE
  291. (DIR [ 1 ] ))- ORD ('A')+ 1 ELSE OI1Il0OlO1I1 := 0 ;GETDIR (OI1Il0OlO1I1 , O101I10lOIOOI );CHDIR (DIR );ISDIRECTORY :=
  292. IORESULT =0 ;CHDIR (O101I10lOIOOI );CHDIR (OI10O00llI );END ;FUNCTION ISFILEOPEN (VAR F):BOOLEAN ;BEGIN ISFILEOPEN :=
  293. (FILEREC (F ). MODE =FMINOUT )OR (FILEREC (F ). MODE =FMOUTPUT )OR (FILEREC (F ). MODE =FMINPUT );END ;FUNCTION IOERROR
  294. (CONST S:STRING ;AHELPCTX:WORD):BOOLEAN ;BEGIN IOERRNUM := IORESULT ;IF IOERRNUM <> 0 THEN BEGIN IOERROR := TRUE ;
  295. {$IFNDEF Windows}IF STRINGS =NIL THEN BEGIN CASE IOERRNUM  OF 2 , 3 :PRINTERROR ('File '+ S + ' not found.', AHELPCTX );
  296. 4 :PRINTERROR ('Too many open files.', AHELPCTX );5 :PRINTERROR ('File '+ S + ' is read-only.', AHELPCTX );100
  297. :PRINTERROR ('Disk read error.', AHELPCTX );101 :PRINTERROR ('Disk write error or disk full.', AHELPCTX );103 :PRINTERROR
  298. ('File '+ S + ' not open or disk not formatted.', AHELPCTX );150 :PRINTERROR ('Disk is write-protected.', AHELPCTX );152
  299. :PRINTERROR ('Drive not ready.', AHELPCTX );159 :PRINTERROR ('Printer out of paper', AHELPCTX );162 :PRINTERROR
  300. ('Hardware failure.', AHELPCTX );ELSE PRINTERROR ('Internal error. '+ S , AHELPCTX );END ;END ELSE
  301. BEGIN {$ENDIF}CASE IOERRNUM  OF 2 , 3 :PRINTERROR (RSGET2 (SFILENOTFOUND , IOERRNUM , LONGINT (@ S )), AHELPCTX );4
  302. :PRINTERROR (RSGET (STOOMANYOPENFILES ), AHELPCTX );5 :PRINTERROR (RSGET2 (SFILEREADONLY , IOERRNUM , LONGINT (@ S )),
  303. AHELPCTX );100 :PRINTERROR (RSGET (SDISKREADERROR ), AHELPCTX );101 :PRINTERROR (RSGET (SDISKFULL ), AHELPCTX );103
  304. :PRINTERROR (RSGET1 (SFILENOTOPEN , LONGINT (@ S )), AHELPCTX );150 :PRINTERROR (RSGET (SDISKWRITEPROTECTED ), AHELPCTX
  305. );152 :PRINTERROR (RSGET (SDRIVENOTREADY ), AHELPCTX );159 :PRINTERROR (RSGET (SOUTOFPAPER ), AHELPCTX );162 :PRINTERROR
  306. (RSGET (SHARDWAREFAILURE ), AHELPCTX );ELSE PRINTERROR (RSGET1 (SINTERNALERROR , IOERRNUM ), AHELPCTX );END ;
  307. {$IFNDEF Windows}END ;{$ENDIF}END ELSE IOERROR := FALSE ;END ;FUNCTION MATCHFILENAMES (CONST SOURCE,DEST:PATHSTR):STRING
  308. ;VAR OO10:WORD;OIlO:INTEGER;O1lIIlO1I0lI,OOO0OOI1ll10:DIRSTR;OII010l00O,O1lO0I00IOlO:NAMESTR;
  309. O1010O1I0I10O,OI1OO1IIOl:EXTSTR;BEGIN {$IFDEF Debug}ASSERT ((DEST [ LENGTH (DEST )] ='\')OR NOT ISDIRECTORY (DEST ),
  310. 'Destination should not be a directory');{$ENDIF}XFSPLIT (SOURCE , O1lIIlO1I0lI , OII010l00O , O1010O1I0I10O );XFSPLIT
  311. (DEST , OOO0OOI1ll10 , O1lO0I00IOlO , OI1OO1IIOl );IF O1lO0I00IOlO =''THEN BEGIN O1lO0I00IOlO := OII010l00O ;OI1OO1IIOl
  312. := O1010O1I0I10O ;END ELSE BEGIN OO10 := CPOS ('*', O1lO0I00IOlO );IF OO10 > 0 THEN BEGIN DELETE (O1lO0I00IOlO , OO10 ,
  313. LENGTH (O1lO0I00IOlO ));O1lO0I00IOlO := O1lO0I00IOlO + COPY (OII010l00O , OO10 , LENGTH (OII010l00O ));END ELSE
  314. BEGIN OO10 := CPOS ('?', O1lO0I00IOlO );IF OO10 > 0 THEN BEGIN FOR OIlO := OO10 TO LENGTH (O1lO0I00IOlO ) DO IF
  315. (O1lO0I00IOlO [ OIlO ] ='?')AND (OIlO <= LENGTH (OII010l00O ))THEN O1lO0I00IOlO [ OIlO ] := OII010l00O [ OIlO ] END ;
  316. END ;IF OI1OO1IIOl <> ''THEN BEGIN OO10 := CPOS ('*', OI1OO1IIOl );IF OO10 > 0 THEN BEGIN DELETE (OI1OO1IIOl , OO10 ,
  317. LENGTH (OI1OO1IIOl ));OI1OO1IIOl := OI1OO1IIOl + COPY (O1010O1I0I10O , OO10 , LENGTH (O1010O1I0I10O ));END ELSE
  318. BEGIN OO10 := CPOS ('?', OI1OO1IIOl );IF OO10 > 0 THEN BEGIN FOR OIlO := OO10 TO LENGTH (OI1OO1IIOl ) DO IF (OI1OO1IIOl [
  319. OIlO ] ='?')AND (OIlO <= LENGTH (O1010O1I0I10O ))THEN OI1OO1IIOl [ OIlO ] := O1010O1I0I10O [ OIlO ] END ;END ;END ;END ;
  320. MATCHFILENAMES := OOO0OOI1ll10 + O1lO0I00IOlO + OI1OO1IIOl ;END ;PROCEDURE REMOVETRAILINGBACKSLASH (VAR DIR:PATHSTR);
  321. BEGIN IF DIR [ LENGTH (DIR )] ='\'THEN DELETE (DIR , LENGTH (DIR ), 1 );END ;PROCEDURE SETHANDLECOUNT (HANDLES:WORD);
  322. BEGIN IF LO (DOSVERSION )>= 5 THEN BEGIN DOSERROR := 0 ;ASM {} MOV AH , 67h {} MOV BX , HANDLES{} INT 21h {} JNC @end {}
  323. MOV DOSERROR, AX {} @end : {} END;CASE DOSERROR  OF 0 :;8 :SETHANDLECOUNTDOS3 (HANDLES );ELSE PRINTERROR
  324. ('SetHandleCount failed. DosError = '+ STRW (DOSERROR ), 0 );END ;END ELSE IF LO (DOSVERSION )>= 3 THEN
  325. SETHANDLECOUNTDOS3 (HANDLES );END ;PROCEDURE SETHANDLECOUNTDOS3 (HANDLES:WORD);CONST O1lIlOIl1I0I=255 ;
  326. TYPE OOIl01IlO0Ol=^OOIl01IlO0O0;OOIl01IlO0O0=ARRAY [ 1 .. O1lIlOIl1I0I]  OF BYTE;VAR OOlIll0O0lll:OOIl01IlO0Ol;
  327. OIlO:INTEGER;OO01:LONGINT;BEGIN IF (LO (DOSVERSION )< 3 )OR (HANDLES > O1lIlOIl1I0I )THEN EXIT ;{$IFDef MsDos}GETMEM
  328. (OOlIll0O0lll , HANDLES );{$ELSE}OO01 := GLOBALDOSALLOC (HANDLES );OOlIll0O0lll := PTR (LONGREC (OO01 ). LO , 0 );
  329. {$ENDIF}FILLCHAR (OOlIll0O0lll ^, HANDLES , $FF );FOR OIlO := 1 TO MEMW [ PREFIXSEG :$32 ]  DO OOlIll0O0lll ^[ OIlO ] :=
  330. MEM [ PREFIXSEG :$18 + OIlO - 1 ] ;MEMW [ PREFIXSEG :$32 ] := HANDLES ;{$IFDEF MsDos}MEML [ PREFIXSEG :$34 ] := LONGINT
  331. (OOlIll0O0lll );{$ELSE}MEML [ PREFIXSEG :$34 ] := LONGINT (PTR (LONGREC (OO01 ). HI , 0 ));{$ENDIF}END ;PROCEDURE XMKDIR
  332. (PATH:PATHSTR);VAR OIlO:INTEGER;OIOl00O1O1O:PATHSTR;BEGIN IF PATH [ LENGTH (PATH )] ='\'THEN DELETE (PATH , LENGTH (PATH
  333. ), 1 );OIlO := CPOS ('\', PATH )+ 1 ;WHILE TRUE  DO BEGIN WHILE (OIlO <= LENGTH (PATH ))AND (PATH [ OIlO ] <> '\') DO INC
  334. (OIlO );IF OIlO > LENGTH (PATH )THEN BEGIN MKDIR (PATH );BREAK ;END ELSE BEGIN OIOl00O1O1O := COPY (PATH , 1 , OIlO - 1
  335. );IF NOT ISDIRECTORY (OIOl00O1O1O )THEN BEGIN MKDIR (OIOl00O1O1O );IF INOUTRES <> 0 THEN EXIT ;END ;INC (OIlO );END ;
  336. END ;END ;PROCEDURE XFSPLIT (CONST PATH:PATHSTR;VAR DIR:DIRSTR;VAR NAME:NAMESTR;VAR EXT:EXTSTR);
  337. {$IFDEF Windows}VAR OIlIl0O00Il:ARRAY [ 0 .. FSPATHNAME]  OF CHAR;OIOO:ARRAY [ 0 .. FSDIRECTORY]  OF CHAR;OO0O:ARRAY [ 0
  338. .. FSFILENAME]  OF CHAR;OIOl:ARRAY [ 0 .. FSEXTENSION]  OF CHAR;{$ENDIF}BEGIN {$IFDEF Windows}STRPCOPY (OIlIl0O00Il ,
  339. PATH );FILESPLIT (OIlIl0O00Il , OIOO , OO0O , OIOl );DIR := STRPAS (OIOO );NAME := STRPAS (OO0O );EXT := STRPAS (OIOl );
  340. {$ELSE}FSPLIT (PATH , DIR , NAME , EXT );{$ENDIF}END ;FUNCTION XPARAMSTR (INDEX:WORD):STRING ;VAR OO1O:STRING ;BEGIN IF
  341. INDEX > PARAMCOUNT THEN XPARAMSTR := ''ELSE BEGIN OO1O := PARAMSTR (INDEX );IF LENGTH (OO1O )>= 1 THEN IF OO1O [ 1 ]
  342. ='/'THEN OO1O [ 1 ] := '-';IF OO1O ='-?'THEN OO1O := '-H';OO1O := UPSTR (OO1O );XPARAMSTR := OO1O ;END ;END ;
  343. CONSTRUCTOR TSMARTBUFSTREAM.INIT (CONST FILENAME:FNAMESTR;MODE,SIZE:WORD);BEGIN INHERITED INIT(FILENAME , MODE , SIZE );
  344. FILEPOSCACHE := - 1 ;GETPOSCACHE := - 1 ;GETSIZECACHE := - 1 ;END ;FUNCTION TSMARTBUFSTREAM.GETPOS :LONGINT ;BEGIN IF
  345. GETPOSCACHE =- 1 THEN GETPOSCACHE := INHERITED GETPOS;GETPOS := GETPOSCACHE ;END ;FUNCTION TSMARTBUFSTREAM.GETSIZE
  346. :LONGINT ;BEGIN IF GETSIZECACHE =- 1 THEN GETSIZECACHE := INHERITED GETSIZE;GETSIZE := GETSIZECACHE ;END ;
  347. PROCEDURE TSMARTBUFSTREAM.READ (VAR BUF;COUNT:WORD);BEGIN IF COUNT > BUFEND - BUFPTR THEN FILEPOSCACHE := - 1 ;
  348. INHERITED READ(BUF , COUNT );IF STATUS =STOK THEN BEGIN IF GETPOSCACHE <> - 1 THEN INC (GETPOSCACHE , COUNT )END ELSE
  349. GETPOSCACHE := - 1 ;END ;PROCEDURE TSMARTBUFSTREAM.RESIZEBUFFER (NEWSIZE:WORD);BEGIN FLUSH ;FREEMEM (BUFFER , BUFSIZE );
  350. GETMEM (BUFFER , NEWSIZE );BUFSIZE := NEWSIZE ;BUFPTR := 0 ;BUFEND := 0 ;END ;PROCEDURE TSMARTBUFSTREAM.SEEK
  351. (POS:LONGINT);ASSEMBLER;ASM {} LES DI , SELF{} MOV AX , WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.FILEPOSCACHE{}
  352. MOV DX , WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.FILEPOSCACHE+ 2 {} OR DX , DX {} JNS @@havepos {} PUSH ES {} PUSH DI {}
  353. CALL TDOSSTREAM.GETPOS{} MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.FILEPOSCACHE, AX {}
  354. MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.FILEPOSCACHE+ 2 , DX {} @@havepos : {} OR DX , DX {} JS @@2 {} LES DI , SELF{}
  355. SUB AX , POS.WORD [ 0 ] {} SBB DX , POS.WORD [ 2 ] {} JNE @@1 {} OR AX , AX {} JE @@1 {}
  356. MOV DX , ES : [ DI ] . TBUFSTREAM.BUFEND{} SUB DX , AX {} JB @@1 {} MOV ES : [ DI ] . TBUFSTREAM.BUFPTR, DX {} JMP @@2 {}
  357. @@1 : PUSH POS.WORD [ 2 ] {} PUSH POS.WORD [ 0 ] {} PUSH ES {} PUSH DI {} PUSH ES {} PUSH DI {} CALL TBUFSTREAM.FLUSH{}
  358. CALL TDOSSTREAM.SEEK{} @@2 : {} LES DI , SELF{} CMP ES : [ DI ] . TSMARTBUFSTREAM.STATUS, STOK{} JNE @@errorexit {}
  359. MOV AX , POS.WORD [ 0 ] {} MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.GETPOSCACHE, AX {} MOV AX , POS.WORD [ 2 ] {}
  360. MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.GETPOSCACHE+ 2 , AX {} JMP @@exit {} @@errorexit : {}
  361. MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.GETPOSCACHE, 0ffffh {}
  362. MOV WORD PTR ES : [ DI ] . TSMARTBUFSTREAM.GETPOSCACHE+ 2 , 0ffffh {} @@exit : {} END;PROCEDURE TSMARTBUFSTREAM.TRUNCATE
  363. ;BEGIN INHERITED TRUNCATE;GETPOSCACHE := - 1 ;GETSIZECACHE := - 1 ;END ;PROCEDURE TSMARTBUFSTREAM.WRITE (VAR BUF;
  364. COUNT:WORD);BEGIN INHERITED WRITE(BUF , COUNT );GETSIZECACHE := - 1 ;FILEPOSCACHE := - 1 ;IF STATUS =STOK THEN BEGIN IF
  365. GETPOSCACHE <> - 1 THEN INC (GETPOSCACHE , COUNT );END ELSE GETPOSCACHE := - 1 ;END ;END .
  366.